home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / programming / source / obrn-a_1.5_src.lha / oberon-a / source3.lha / Source / OC / OCP.mod < prev    next >
Encoding:
Text File  |  1995-01-26  |  35.4 KB  |  1,069 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: OCP.mod $
  4.   Description: Code selection for standard procedures
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 5.9 $
  8.       $Author: fjc $
  9.         $Date: 1995/01/26 00:17:17 $
  10.  
  11.   Copyright © 1990-1993, ETH Zuerich
  12.   Copyright © 1993-1995, Frank Copeland
  13.   This module forms part of the OC program
  14.   See OC.doc for conditions of use and distribution
  15.  
  16.   Log entries are at the end of the file.
  17.  
  18. *************************************************************************)
  19.  
  20. <* STANDARD- *> <* MAIN- *> <*$ LongVars+ *>
  21.  
  22. MODULE OCP;
  23.  
  24. IMPORT SYS := SYSTEM, OCM, OCS, OCT, OCC, OCI, OCE;
  25.  
  26.  
  27. (* --- Local declarations ----------------------------------------------- *)
  28.  
  29. CONST
  30.  
  31.   (* object modes *)
  32.   Var = OCM.Var; VarX = OCM.VarX; Ind = OCM.Ind; IndX = OCM.IndX;
  33.   RegI = OCM.RegI; RegX = OCM.RegX; Lab = OCM.Lab; LabI = OCM.LabI;
  34.   Con = OCM.Con; Push = OCM.Push; Pop = OCM.Pop; Coc = OCM.Coc;
  35.   Reg = OCM.Reg; Fld = OCM.Fld; Typ = OCM.Typ; Abs = OCM.Abs;
  36.   XProc = OCM.XProc; LProc = OCM.LProc;
  37.  
  38.   (* System flags *)
  39.  
  40.   OberonFlag = OCM.OberonFlag; M2Flag = OCM.M2Flag; CFlag = OCM.CFlag;
  41.   BCPLFlag = OCM.BCPLFlag; AsmFlag = OCM.AsmFlag;
  42.  
  43.   (* structure forms *)
  44.   Undef = OCT.Undef; Byte = OCT.Byte; Bool = OCT.Bool; Char = OCT.Char;
  45.   SInt = OCT.SInt; Int = OCT.Int; LInt = OCT.LInt; Real = OCT.Real;
  46.   LReal = OCT.LReal; Set = OCT.Set; String = OCT.String;
  47.   NilTyp = OCT.NilTyp; NoTyp = OCT.NoTyp; Pointer = OCT.Pointer;
  48.   ProcTyp = OCT.ProcTyp; Array = OCT.Array; DynArr = OCT.DynArr;
  49.   Record = OCT.Record; PtrTyp = OCT.PtrTyp; AdrTyp = OCT.AdrTyp;
  50.   BPtrTyp = OCT.BPtrTyp; BSet = OCT.BSet; WSet = OCT.WSet; Word = OCT.Word;
  51.   Longword = OCT.Longword; TagTyp = OCT.TagTyp;
  52.  
  53.   intSet   = {SInt, Int, LInt};
  54.   realSet  = {Real, LReal};
  55.   setSet   = {BSet, WSet, Set};
  56.   ptrSet   = {Pointer, PtrTyp, AdrTyp, BPtrTyp};
  57.   uptrSet  = {AdrTyp, BPtrTyp};
  58.   allSet   = {0 .. 31};
  59.   adrSet   = {LInt, Pointer, PtrTyp, AdrTyp, Longword};
  60.   bitOpSet = intSet + setSet + {Byte, Char, Word, Longword};
  61.   putSet   =
  62.     {Undef .. LInt, Word, Longword, ProcTyp} + setSet + ptrSet + realSet;
  63.  
  64.   (* CPU Registers *)
  65.  
  66.   D0 = 0; D1 = 1; D7 = 7; A0 = 8; A1 = 9; A3 = 11; A4 = 12; A5 = 13;
  67.   A6 = 14; A7 = 15; BP = A4; FP = A5; SP = A7;
  68.   DataRegs = {D0 .. D7};
  69.   AdrRegs = {A0 .. A7};
  70.  
  71.   (* Data sizes *)
  72.  
  73.   B = 1; W = 2; L = 4;
  74.  
  75. (* CONST mname = "OCP"; *)
  76.  
  77. (* --- Procedure declarations ------------------------------------------- *)
  78.  
  79. (*------------------------------------*)
  80. PROCEDURE CheckCleanupProc (VAR x : OCT.Item);
  81.  
  82.   (* CONST pname = "CheckCleanupProc"; *)
  83.  
  84.   VAR par : OCT.Object; typ : OCT.Struct;
  85.  
  86. BEGIN (* CheckCleanupProc *)
  87.   (* OCM.TraceIn (mname, pname); *)
  88.   IF (x.mode = XProc) OR (x.typ.form = ProcTyp) THEN
  89.     IF x.mode = XProc THEN par := x.obj.link; typ := x.typ
  90.     ELSE par := x.typ.link; typ := x.typ.BaseTyp;
  91.     END;
  92.     IF OCI.IsParam (par) THEN OCS.Mark (117) END;
  93.     IF typ # OCT.notyp THEN OCS.Mark (301) END
  94.   ELSE
  95.     OCS.Mark (300)
  96.   END
  97.   (* ;OCM.TraceOut (mname, pname); *)
  98. END CheckCleanupProc;
  99.  
  100. (*------------------------------------*)
  101. PROCEDURE NeedsTag (typ : OCT.Struct) : BOOLEAN;
  102.  
  103.   VAR fld : OCT.Object;
  104.  
  105. BEGIN (* NeedsTag *)
  106.   IF (typ.form IN {Pointer, Record}) & (typ.sysflg = OberonFlag) THEN
  107.     RETURN TRUE
  108.   ELSIF typ.form IN {Array, DynArr} THEN
  109.     RETURN NeedsTag (typ.BaseTyp)
  110.   END;
  111.   RETURN FALSE
  112. END NeedsTag;
  113.  
  114. (*------------------------------------*)
  115. PROCEDURE SaveRegs * ( fctno : INTEGER; VAR R : SET );
  116.   VAR x : OCT.Item;
  117. BEGIN (* SaveRegs *)
  118.   CASE fctno OF
  119.     OCT.pDISPOSE, OCT.pMOVE :
  120.       x.mode := Undef; OCC.SaveRegisters (R, x, OCC.AllRegs)
  121.     |
  122.   ELSE
  123.     R := {}
  124.   END
  125. END SaveRegs;
  126.  
  127. (*------------------------------------*)
  128. PROCEDURE StPar1 * (VAR x : OCT.Item; fctno : INTEGER; VAR R : SET);
  129.  
  130.   (* CONST pname = "StPar1"; *)
  131.  
  132.   VAR f, f1 : INTEGER; y, z, r0, r1 : OCT.Item;
  133.       L0, L1 : INTEGER; size : LONGINT; par : OCT.Object;
  134.       typ : OCT.Struct; desc : OCT.Desc;
  135.  
  136. BEGIN (* StPar1 *)
  137.   (* OCM.TraceIn (mname, pname); *)
  138.   f := x.typ.form; size := x.typ.size;
  139.   CASE fctno OF
  140.     OCT.pABS :
  141.       IF f IN intSet THEN
  142.         IF x.mode = Con THEN
  143.           x.a0 := ABS (x.a0)
  144.         ELSE
  145.           OCI.Load (x);                                (*    MOVE.z  x,Dn *)
  146.           OCC.PutF1 (OCC.TST, size, x);                (*    TST.z   Dn   *)
  147.           OCC.PutWord (6A02H);                         (*    BPL     1$   *)
  148.           OCC.PutF1 (OCC.NEG, size, x)                 (*    NEG.z   Dn   *)
  149.         END
  150.       ELSIF f IN realSet THEN
  151.         OCC.LoadRegParams1 (R, x);
  152.         OCC.CallKernel (OCC.kSPAbs);
  153.         OCC.RestoreRegisters (R, x)
  154.       ELSE
  155.         OCS.Mark (111)
  156.       END
  157.     |
  158.     OCT.pCAP :
  159.       IF (f = String) & (x.a1 <= 2) THEN
  160.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  161.       END;
  162.       IF f = Char THEN
  163.         IF x.mode = Con THEN
  164.           x.a0 := ORD (CAP (CHR (x.a0)))
  165.         ELSE
  166.           y.mode := Con; y.typ := OCT.chartyp;
  167.           OCI.Load (x);                                (*    MOVE x,Dn    *)
  168.           y.a0 := ORD ("a");
  169.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "a", Dn *)
  170.           OCC.PutWord (6510H);                         (*    BCS 1$       *)
  171.           y.a0 := ORD ("z");
  172.           OCC.PutF6 (OCC.CMPI, B, y, x);               (*    CMPI "z", Dn *)
  173.           OCC.PutWord (6306H);                         (*    BLS 0$       *)
  174.           y.a0 := 0E0H; OCC.PutF6 (OCC.CMPI, B, y, x); (*    CMPI 0E0X,Dn *)
  175.           OCC.PutWord (6504H);                         (*    BCS 1$       *)
  176.           y.a0 := 0DFH; OCC.PutF6 (OCC.ANDI, B, y, x); (* 0$ ANDI 0DFH,Dn *)
  177.         END                                            (* 1$              *)
  178.       ELSE
  179.         OCS.Mark (111); x.typ := OCT.chartyp
  180.       END
  181.     |
  182.     OCT.pCHR :
  183.       IF ~(f IN {Undef, Byte, SInt, Int, LInt}) THEN OCS.Mark (111) END;
  184.       IF ~(f IN {Byte, SInt}) & (x.mode # Con) THEN OCI.Load (x) END;
  185.       x.typ := OCT.chartyp
  186.     |
  187.     OCT.pENTIER :
  188.       IF f IN realSet THEN
  189.         OCC.LoadRegParams1 (R, x);
  190.         OCC.CallKernel (OCC.kSPFix);
  191.         OCC.RestoreRegisters (R, x)
  192.       ELSE OCS.Mark (111)
  193.       END;
  194.       x.typ := OCT.linttyp;
  195.     |
  196.     OCT.pHALT :
  197.       IF (f IN intSet) & (x.mode = Con) THEN
  198.         r0.mode := Reg; r0.a0 := D0;
  199.         OCC.Move (L, x, r0);                     (* MOVE.L x,D0          *)
  200.         y.mode := Con; y.a0 := 0; y.typ := OCT.stringtyp;
  201.         y.label := OCT.ConstLabel;
  202.         OCC.PutF2 (OCC.LEA, y, A0);              (* LEA    ModuleName,A0 *)
  203.         y.a0 := (OCS.line * 10000H) + OCS.col; y.typ := OCT.linttyp;
  204.         r1.mode := Reg; r1.a0 := D1;
  205.         OCC.Move (L, y, r1);                     (* MOVE.L pos,D1        *)
  206.         OCC.CallKernel (OCC.kHalt)               (* JSR    Kernel_Halt   *)
  207.       ELSE
  208.         OCS.Mark (17)
  209.       END;
  210.       x.typ := OCT.notyp
  211.     |
  212.     OCT.pLONG :
  213.       IF (f = String) & (x.a1 <= 2) THEN
  214.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  215.       END;
  216.       IF f = SInt THEN OCE.ConvertInts (x, OCT.inttyp)
  217.       ELSIF f = Int THEN OCE.ConvertInts (x, OCT.linttyp)
  218.       ELSIF f = BSet THEN
  219.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  220.         IF x.mode # Con THEN
  221.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.wsettyp;
  222.           OCI.Load (x); OCC.Move (B, y, x)
  223.         END;
  224.         x.typ := OCT.wsettyp
  225.       ELSIF f = WSet THEN
  226.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  227.         IF x.mode # Con THEN
  228.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.settyp;
  229.           OCI.Load (x); OCC.Move (W, y, x)
  230.         END;
  231.         x.typ := OCT.settyp
  232.       ELSIF f = Real THEN
  233.         x.typ := OCT.lrltyp
  234.       ELSIF f = Char THEN
  235.         IF x.mode # Con THEN
  236.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  237.           OCI.Load (x); OCC.Move (B, y, x)
  238.         END;
  239.         x.typ := OCT.linttyp
  240.       ELSE
  241.         OCS.Mark (111)
  242.       END
  243.     |
  244.     OCT.pMAX :
  245.       IF x.mode = Typ THEN
  246.         x.mode := Con;
  247.         CASE f OF
  248.           Bool  : x.a0 := OCM.MaxBool                      |
  249.           Char  : x.a0 := OCM.MaxChar                      |
  250.           SInt  : x.a0 := OCM.MaxSInt                      |
  251.           Int   : x.a0 := OCM.MaxInt                       |
  252.           LInt  : x.a0 := OCM.MaxLInt                      |
  253.           Real  : x.a0 := 07F7FFFFFH                       |
  254.           LReal : x.a0 := 07F7FFFFFH                       |
  255.           BSet  : x.a0 := OCM.MaxBSet; x.typ := OCT.inttyp |
  256.           WSet  : x.a0 := OCM.MaxWSet; x.typ := OCT.inttyp |
  257.           Set   : x.a0 := OCM.MaxSet; x.typ := OCT.inttyp  |
  258.         ELSE
  259.           OCS.Mark (111)
  260.         END; (* CASE f *)
  261.       ELSE
  262.         OCS.Mark (110)
  263.       END
  264.     |
  265.     OCT.pMIN :
  266.       IF x.mode = Typ THEN
  267.         x.mode := Con;
  268.         CASE f OF
  269.           Bool  : x.a0 := OCM.MinBool                               |
  270.           Char  : x.a0 := OCM.MinChar                               |
  271.           SInt  : x.a0 := OCM.MinSInt                               |
  272.           Int   : x.a0 := OCM.MinInt                                |
  273.           LInt  : x.a0 := OCM.MinLInt                               |
  274.           Real  : x.a0 := 0FF7FFFFFH                                |
  275.           LReal : x.a0 := 0FF7FFFFFH                                |
  276.           BSet, WSet, Set : x.a0 := OCM.MinSet; x.typ := OCT.inttyp |
  277.         ELSE
  278.           OCS.Mark (111)
  279.         END; (* CASE f *)
  280.       ELSE
  281.         OCS.Mark (110)
  282.       END
  283.     |
  284.     OCT.pNEW :
  285.       IF (f = Pointer) & (x.mode # Con) THEN
  286.         IF x.rdOnly THEN OCS.Mark (324) END;
  287.         typ := x.typ; f1 := typ.sysflg;
  288.         typ := typ.BaseTyp; f := typ.form;
  289.         IF f = DynArr THEN
  290.           OCI.UnloadDesc (x);
  291.           desc := x.desc; IF desc = NIL THEN desc := OCT.AllocDesc() END;
  292.           desc.lev := x.lev; desc.mode := x.mode; desc.a0 := x.a0;
  293.           desc.a1 := x.a1; desc.a2 := x.a2; x.desc := desc;
  294.         END;
  295.         z.mode := Undef; OCC.SaveRegisters (R, z, OCC.AllRegs);
  296.         IF (f = DynArr) & (x.mode IN {VarX, IndX, RegI, RegX}) THEN
  297.           IF x.mode IN {RegI, RegX} THEN OCC.ReserveReg (SHORT (x.a0)) END;
  298.           IF x.mode # RegI THEN OCC.ReserveReg (SHORT (x.a2)) END
  299.         END;
  300.         z.mode := Push; z.a0 := SP;
  301.         IF (f1 = OberonFlag) & NeedsTag (typ) THEN
  302.           IF f = Record THEN
  303.             OCC.PutWord (2F3CH);
  304.             OCC.PutLongRef (0, typ.label);       (* MOVE.L #tag,-(A7)   *)
  305.           ELSIF f = Array THEN
  306.             y.mode := Con; y.a0 := typ.size; y.typ := OCT.linttyp;
  307.             WHILE typ.form = Array DO typ := typ.BaseTyp END;
  308.             OCC.PutWord (2F3CH);
  309.             OCC.PutLongRef (0, typ.label);       (* MOVE.L #tag,-(A7)   *)
  310.             OCC.Move (L, y, z);                   (* MOVE.L #size,-(A7)  *)
  311.           ELSIF f = DynArr THEN
  312.             WHILE typ.form = DynArr DO typ := typ.BaseTyp END;
  313.             WHILE typ.form = Array DO typ := typ.BaseTyp END;
  314.             OCC.PutWord (2F3CH);
  315.             OCC.PutLongRef (0, typ.label);       (* MOVE.L #tag,-(A7)   *)
  316.           END
  317.         ELSIF f # DynArr THEN
  318.           y.mode := Con; y.a0 := typ.size; y.typ := OCT.linttyp;
  319.           OCC.Move (L, y, z);                     (* MOVE.L #size, -(A7) *)
  320.         END
  321.       ELSE OCS.Mark (111)
  322.       END
  323.     |
  324.     OCT.pODD :
  325.       IF f IN intSet THEN
  326.         y.mode := Con; y.a0 := 0; y.typ := OCT.inttyp;
  327.         IF f = SInt THEN OCC.Bit (OCC.BTST, y, x);
  328.         ELSE OCI.Load (x); OCC.Bit (OCC.BTST, y, x); OCI.Unload (x)
  329.         END;
  330.       ELSE
  331.         OCS.Mark (111)
  332.       END;
  333.       OCE.setCC (x, OCC.NE)
  334.     |
  335.     OCT.pORD :
  336.       IF (f = String) & (x.a1 <= 2) THEN
  337.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  338.       END;
  339.       IF (f = Char) OR (f = Byte) THEN
  340.         IF x.mode # Con THEN
  341.           y := x; x.mode := Con; x.a0 := 0; x.typ := OCT.inttyp;
  342.           OCI.Load (x); OCC.Move (B, y, x)
  343.         END
  344.       ELSE
  345.         OCS.Mark (111)
  346.       END;
  347.       x.typ := OCT.inttyp
  348.     |
  349.     OCT.pSHORT :
  350.       IF f = LInt THEN (* range test missing *)
  351.         IF x.mode = Con THEN
  352.           OCE.SetIntType (x); IF x.typ.form = LInt THEN OCS.Mark (203) END
  353.         ELSE
  354.           OCI.Load (x)
  355.         END;
  356.         x.typ := OCT.inttyp
  357.       ELSIF f = Int THEN (* range test missing *)
  358.         IF x.mode = Con THEN
  359.           OCE.SetIntType (x); IF x.typ.form # SInt THEN OCS.Mark (203) END
  360.         ELSE
  361.           OCI.Load (x)
  362.         END;
  363.         x.typ := OCT.sinttyp
  364.       ELSIF f = Set THEN (* range test missing *)
  365.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  366.         IF x.mode # Con THEN OCI.Load (x) END;
  367.         x.typ := OCT.wsettyp
  368.       ELSIF f = WSet THEN (* range test missing *)
  369.         IF OCS.option [OCS.standard] THEN OCS.Mark (915) END;
  370.         IF x.mode # Con THEN OCI.Load (x) END;
  371.         x.typ := OCT.bsettyp
  372.       ELSIF f = LReal THEN
  373.         x.typ := OCT.realtyp
  374.       ELSE
  375.         OCS.Mark (111)
  376.       END
  377.     |
  378.     OCT.pADR :
  379.       OCI.Adr (x); x.typ := OCT.adrtyp
  380.     |
  381.     OCT.pCC :
  382.       IF (f = SInt) & (x.mode = Con) THEN
  383.         IF (x.a0 >= 0) & (x.a0 < 16) THEN OCE.setCC (x, x.a0)
  384.         ELSE OCS.Mark (219)
  385.         END
  386.       ELSE OCS.Mark (17)
  387.       END
  388.     |
  389.     OCT.pDISPOSE :
  390.       IF f IN ptrSet THEN
  391.         IF x.rdOnly THEN OCS.Mark (324) END;
  392.         IF x.typ.sysflg = BCPLFlag THEN
  393.           y := x; OCI.Load (y);
  394.           OCC.PutF5 (OCC.ADD, L, y, y);               (* ADD.L  Dm, Dm  *)
  395.           OCC.PutF5 (OCC.ADD, L, y, y);               (* ADD.L  Dm, Dm  *)
  396.           OCC.Move (L, y, x); OCI.Unload (y)
  397.         END;
  398.         y.mode := Push; y.a0 := SP;
  399.         IF x.mode IN {Ind, IndX} THEN OCI.MoveAdr (x, y)
  400.         ELSE OCC.PutF3 (OCC.PEA, x)
  401.         END;
  402.         OCI.Unload (x);
  403.         OCC.CallKernel (OCC.kDispose);
  404.         z.mode := Undef; OCC.RestoreRegisters (R, z)
  405.       ELSE
  406.         OCS.Mark (111)
  407.       END;
  408.       x.typ := OCT.notyp
  409.     |
  410.     OCT.pSIZE :
  411.       IF x.mode = Typ THEN x.a0 := x.typ.size
  412.       ELSE OCS.Mark (110); x.a0 := 1
  413.       END;
  414.       x.mode := Con; OCE.SetIntType (x)
  415.     |
  416.     OCT.pSTRLEN :
  417.       IF ((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char) THEN
  418.         y := x; OCI.LoadAdr (y); y.mode := Pop;       (*    LEA    <y>,Ay *)
  419.         x.mode := Con; x.a0 := 0; x.typ := OCT.linttyp;
  420.         OCI.Load (x);                                 (*    MOVEQ  #0,Dx  *)
  421.         OCC.PutF1 (OCC.TST, B, y); OCC.FreeReg (y);   (* 1$ TST.B  (Ay)+  *)
  422.         OCC.PutWord (6704H);                          (*    BEQ    2$     *)
  423.         OCC.PutF7 (OCC.ADDQ, L, 1, x);                (*    ADDQ.L #1,Dx  *)
  424.         OCC.PutWord (60F8H);                          (*    BRA    1$     *)
  425.       ELSIF f = String THEN                           (* 2$               *)
  426.         x.mode := Con; x.a0 := x.a1 - 1; x.typ := OCT.linttyp
  427.       ELSE
  428.         OCS.Mark (111)
  429.       END
  430.     |
  431.     OCT.pASH :
  432.       IF f IN intSet THEN
  433.         OCI.Load (x); IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END
  434.       ELSE
  435.         OCS.Mark (111)
  436.       END
  437.     |
  438.     OCT.pASSERT :
  439.       IF f = Bool THEN
  440.         IF x.mode = Con THEN
  441.           IF x.a0 = 0 THEN OCS.Mark (319) ELSE OCS.Mark (320) END;
  442.           OCE.setCC (x, OCC.T)
  443.         END;
  444.       ELSE OCS.Mark (120)
  445.       END
  446.     |
  447.     OCT.pCOPY :
  448.       IF
  449.         ~((((f = Array) OR (f = DynArr)) & (x.typ.BaseTyp.form = Char))
  450.           OR (f = String))
  451.       THEN
  452.         OCS.Mark (111)
  453.       END
  454.     |
  455.     OCT.pDEC, OCT.pINC :
  456.       IF x.mode >= Con THEN     OCS.Mark (112)
  457.       ELSIF ~(f IN intSet) THEN OCS.Mark (111)
  458.       ELSIF x.rdOnly THEN OCS.Mark (324)
  459.       END
  460.     |
  461.     OCT.pINCL, OCT.pEXCL :
  462.       IF x.mode >= Con THEN     OCS.Mark (112)
  463.       ELSIF ~(f IN setSet) THEN OCS.Mark (111); x.typ := OCT.settyp
  464.       ELSIF x.rdOnly THEN OCS.Mark (324)
  465.       END
  466.     |
  467.     OCT.pLEN :
  468.       IF (f # DynArr) & (f # Array) THEN OCS.Mark (131) END
  469.     |
  470.     OCT.pAND, OCT.pOR, OCT.pXOR :
  471.       IF ~(f IN bitOpSet) THEN OCS.Mark (111) END
  472.     |
  473.     OCT.pBIT, OCT.pGET, OCT.pPUT :
  474.       IF (f IN intSet) & (x.mode = Con) THEN
  475.         x.mode := Abs
  476.       ELSIF f IN adrSet THEN
  477.         IF x.mode = Var THEN
  478.           x.mode := Ind; x.a1 := 0
  479.         ELSE
  480.           OCC.GetAReg (y); OCC.Move (L, x, y);
  481.           x := y; x.mode := RegI; x.a1 := 0
  482.         END
  483.       ELSE
  484.         OCS.Mark (111)
  485.       END
  486.     |
  487.     OCT.pGETREG, OCT.pPUTREG, OCT.pREG :
  488.       IF (f IN intSet) & (x.mode = Con) THEN
  489.         IF (0 <= x.a0) & (x.a0 <= 15) THEN
  490.           x.mode := Reg;
  491.           IF fctno = OCT.pREG THEN
  492.             OCC.ReserveReg (SHORT (x.a0)); x.typ := OCT.lwordtyp
  493.           END
  494.         ELSE OCS.Mark (219)
  495.         END
  496.       ELSE
  497.         OCS.Mark (17)
  498.       END
  499.     |
  500.     OCT.pLSH, OCT.pROT :
  501.       IF (f = String) & (x.a1 <= 2) THEN
  502.         x.a0 := x.a2; x.typ := OCT.chartyp; f := Char
  503.       END;
  504.       IF f IN bitOpSet THEN OCI.Load (x)
  505.       ELSE OCS.Mark (111)
  506.       END
  507.     |
  508.     OCT.pSYSNEW :
  509.       IF ~(f IN ptrSet) OR (x.mode = Con) THEN OCS.Mark (111)
  510.       ELSIF x.rdOnly THEN OCS.Mark (324)
  511.       ELSIF NeedsTag (x.typ) THEN OCS.Mark (339)
  512.       ELSE y.mode := Undef; OCC.SaveRegisters (R, y, OCC.AllRegs)
  513.       END
  514.     |
  515.     OCT.pVAL : IF x.mode # Typ THEN OCS.Mark (110) END
  516.     |
  517.     OCT.pMOVE :
  518.       IF (f IN adrSet) THEN
  519.         y.mode := Push; y.a0 := SP;
  520.         OCC.Move (L, x, y); OCI.Unload (x);
  521.       ELSE
  522.         OCS.Mark (111)
  523.       END
  524.     |
  525.     OCT.pTAG :
  526.       typ := x.typ; f1 := typ.sysflg;
  527.       IF f = Pointer THEN typ := typ.BaseTyp END;
  528.       IF (typ.form = Record) & (f1 = OberonFlag) THEN
  529.         IF x.mode = Typ THEN (* Type *)
  530.           x.mode := LabI; x.a0 := 0; x.a1 := 4; x.label := typ.label
  531.         ELSIF (x.mode <= RegX) & (f = Pointer) THEN (* Pointer variable *)
  532.           OCE.DeRef (x); x.a1 := -4
  533.         ELSIF (x.mode = Ind) & (x.obj # NIL) & (x.obj # OCC.wasderef) THEN
  534.           (* VAR parameter *)
  535.           x.mode := Var; INC (x.a0, 4)
  536.         ELSE (* Bzzzzt! *)
  537.           OCS.Mark (338)
  538.         END
  539.       ELSIF f = PtrTyp THEN
  540.         IF (x.mode <= RegX) THEN (* Pointer variable *)
  541.           IF x.mode = Var THEN
  542.             IF OCS.pragma [OCS.nilChk] THEN
  543.               y := x;
  544.               OCC.PutF1 (OCC.TST, L, y); OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  545.               OCI.Unload (y)
  546.             END;
  547.             x.mode := Ind
  548.           ELSE
  549.             y := x; y.typ := OCT.ptrtyp; OCC.GetAReg (x);
  550.             IF OCS.pragma [OCS.nilChk] THEN
  551.               OCI.Load (y); OCC.TrapCC (OCC.NilCheck, OCC.EQ);
  552.             END;
  553.             OCC.Move (L, y, x); OCI.Unload (y); x.mode := RegI
  554.           END;
  555.           x.a1 := -4; x.rdOnly := FALSE
  556.         ELSE (* Bzzzzt! *)
  557.           OCS.Mark (338)
  558.         END
  559.       ELSE
  560.         OCS.Mark (338)
  561.       END;
  562.       x.typ := OCT.tagtyp; x.rdOnly := FALSE
  563.     |
  564.   ELSE
  565.     OCS.Mark (1014); OCS.Mark (fctno)
  566.   END; (* CASE fctno *)
  567.   (* ;OCM.TraceOut (mname, pname); *)
  568. END StPar1;
  569.  
  570. (*------------------------------------*)
  571. PROCEDURE StPar2 * (
  572.   VAR par1, par2 : OCT.Item; fctno : INTEGER; VAR R : SET);
  573.  
  574.   (* CONST pname = "StPar2"; *)
  575.  
  576.   VAR f : INTEGER; op, dim : INTEGER; typ, btyp, t1 : OCT.Struct;
  577.       freePar2 : BOOLEAN; L0, L1 : INTEGER; x, y, r0, r1 : OCT.Item;
  578.       dsc : OCT.Desc;
  579.  
  580. BEGIN (* StPar2 *)
  581.   (* OCM.TraceIn (mname, pname); *)
  582.   f := par2.typ.form; freePar2 := FALSE;
  583.   IF fctno < OCT.TwoPar THEN OCS.Mark (64); RETURN END;
  584.   CASE fctno OF
  585.     OCT.pASH, OCT.pLSH, OCT.pROT :
  586.       IF
  587.         ((fctno = OCT.pASH) & (f IN intSet)) OR
  588.         ((fctno # OCT.pASH) & (f IN bitOpSet))
  589.       THEN
  590.         IF (par2.mode = Con) & (par2.a0 = 0) THEN RETURN END;
  591.         IF fctno = OCT.pASH THEN op := OCC.ASR
  592.         ELSIF fctno = OCT.pLSH THEN op := OCC.LSR
  593.         ELSE op := OCC.ROR
  594.         END;
  595.         IF par2.mode = Con THEN
  596.           IF par2.a0 < 0 THEN par2.a0 := -par2.a0 ELSE INC (op, 100H) END;
  597.           IF par2.a0 > 8 THEN OCI.Load (par2); freePar2 := TRUE END;
  598.           OCC.Shift (op, par1.typ.size, par2, par1);
  599.           IF freePar2 THEN OCC.FreeReg (par2) END
  600.         ELSE
  601.           OCI.Load (par2);                         (*    MOVE.L <par2>,Dn *)
  602.           OCC.PutF1 (OCC.TST, par2.typ.size, par2);(*    TST.?  Dn        *)
  603.           L0 := OCC.pc; OCC.PutWord (6A00H);       (*    BPL.S  1$        *)
  604.           OCC.PutF1 (OCC.NEG, par2.typ.size, par2);(*    NEG.?  Dn        *)
  605.           OCC.Shift (op, par1.typ.size, par2, par1);
  606.                                                    (*    opR.?  Dn,<par1> *)
  607.           L1 := OCC.pc; OCC.PutWord (6000H);       (*    BRA.S  $2        *)
  608.           OCC.PatchWord (L0, OCC.pc - L0 - 2);
  609.           OCC.Shift (op+100H, par1.typ.size, par2, par1);
  610.                                                    (* 1$ opL.?  Dn,<par1> *)
  611.           OCC.PatchWord (L1, OCC.pc - L1 - 2);     (* 2$                  *)
  612.         END
  613.       ELSE
  614.         OCS.Mark (111)
  615.       END
  616.     |
  617.     OCT.pASSERT :
  618.       IF (par2.mode = Con) & (f IN intSet) THEN
  619.         IF par1.mode # Coc THEN
  620.           OCC.PutF1 (OCC.TST, B, par1);          (*    TST.B  <par1>      *)
  621.           OCI.Unload (par1); L0 := OCC.pc;
  622.           OCC.PutWord (OCC.BNE)                  (*    BNE.S  2$          *)
  623.         ELSE
  624.           op := OCC.Bcc + (SHORT (par1.a0) * 100H);
  625.           OCC.PutWord (op);
  626.           OCC.PutWord (SHORT (par1.a1));         (*    Bcc    2$          *)
  627.           L0 := OCC.pc - 2; OCC.FixLink (par1.a2);
  628.         END;
  629.         r0.mode := Reg; r0.a0 := D0;
  630.         OCC.Move (L, par2, r0);               (* 1$ MOVE.L #par2,D0      *)
  631.         OCI.Unload (par2);
  632.         x.mode := Con; x.a0 := 0; x.typ := OCT.stringtyp;
  633.         x.label := OCT.ConstLabel;
  634.         OCC.PutF2 (OCC.LEA, x, A0);           (*    LEA    ModuleName,A0 *)
  635.         x.a0 := (OCS.line * 10000H) + OCS.col; x.typ := OCT.linttyp;
  636.         r1.mode := Reg; r1.a0 := D1;
  637.         OCC.Move (L, x, r1);                  (*    MOVE.L pos,D1        *)
  638.         OCC.CallKernel (OCC.kHalt);           (*    JSR    Kernel.Halt   *)
  639.         IF par1.mode # Coc THEN               (* 2$                      *)
  640.           OCC.PatchWord (L0, OCC.pc - L0 - 2)
  641.         ELSE OCC.FixLink (L0)
  642.         END;
  643.       ELSE OCS.Mark (17)
  644.       END;
  645.       par1.typ := OCT.notyp
  646.     |
  647.     OCT.pDEC, OCT.pINC :
  648.       IF par1.typ # par2.typ THEN
  649.         IF (par2.mode = Con) & (f IN intSet) THEN par2.typ := par1.typ
  650.         ELSIF (par1.typ.form = Int) & (f = SInt) THEN
  651.           OCE.ConvertInts (par2, OCT.inttyp)
  652.         ELSIF (par1.typ.form = LInt) & (f IN {SInt, Int}) THEN
  653.           OCE.ConvertInts (par2, OCT.linttyp)
  654.         ELSE OCS.Mark (111)
  655.         END
  656.       ELSIF par2.mode # Con THEN
  657.         OCI.Load (par2)
  658.       END;
  659.       IF fctno = OCT.pDEC THEN op := OCC.SUB ELSE op := OCC.ADD END;
  660.       OCC.PutF5 (op, par1.typ.size, par2, par1);
  661.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  662.       par1.typ := OCT.notyp
  663.     |
  664.     OCT.pEXCL :
  665.       OCE.Set0 (x, par2);
  666.       IF x.mode = Con THEN
  667.         x.a0 := SYS.VAL (LONGINT, allSet - SYS.VAL (SET, x.a0));
  668.         OCC.PutF6 (OCC.ANDI, par1.typ.size, x, par1)
  669.       ELSE
  670.         OCC.PutF1 (OCC.NOT, L, x);
  671.         OCC.PutF5 (OCC.AND, par1.typ.size, x, par1)
  672.       END;
  673.       par1.typ := OCT.notyp
  674.     |
  675.     OCT.pINCL :
  676.       OCE.Set0 (x, par2);
  677.       IF x.mode = Con THEN OCC.PutF6 (OCC.ORI, par1.typ.size, x, par1)
  678.       ELSE OCC.PutF5 (OCC.iOR, par1.typ.size, x, par1)
  679.       END;
  680.       par1.typ := OCT.notyp
  681.     |
  682.     OCT.pLEN :
  683.       IF (par2.mode = Con) & (f = SInt) THEN
  684.         dim := SHORT (par2.a0); typ := par1.typ;
  685.         WHILE (dim > 0) & (typ.form IN {DynArr, Array}) DO
  686.           typ := typ.BaseTyp; DEC (dim)
  687.         END;
  688.         IF (dim # 0) OR ~(typ.form IN {DynArr, Array}) THEN OCS.Mark (132)
  689.         ELSE
  690.           IF typ.form = DynArr THEN OCI.DescItem (par1, par1.desc, typ.adr)
  691.           ELSE par1.mode := Con; par1.a0 := typ.n
  692.           END;
  693.           par1.typ := OCT.linttyp
  694.         END
  695.       ELSE
  696.         OCS.Mark (111)
  697.       END
  698.     |
  699.     OCT.pAND, OCT.pOR, OCT.pXOR :
  700.       IF f IN bitOpSet THEN
  701.         IF (par1.mode = Con) & (par2.mode = Con) THEN
  702.           IF fctno = OCT.pAND THEN
  703.             par1.a0 := SYS.AND (par1.a0, par2.a0)
  704.           ELSIF fctno = OCT.pXOR THEN
  705.             par1.a0 := SYS.XOR (par1.a0, par2.a0)
  706.           ELSE
  707.             par1.a0 := SYS.LOR (par1.a0, par2.a0)
  708.           END;
  709.           IF f IN intSet THEN OCE.SetIntType (par1) END
  710.         ELSE
  711.           IF fctno = OCT.pAND THEN op := OCC.AND
  712.           ELSIF fctno = OCT.pXOR THEN op := OCC.EOR
  713.           ELSE op := OCC.iOR
  714.           END;
  715.           IF par1.mode = Con THEN
  716.             IF par1.typ.form # par2.typ.form THEN par1.typ := par2.typ END;
  717.             OCI.Load (par2); OCC.PutF5 (op, par2.typ.size, par1, par2);
  718.             par1 := par2
  719.           ELSIF par2.mode = Con THEN
  720.             IF par2.typ.form # par1.typ.form THEN par2.typ := par1.typ END;
  721.             OCI.Load (par1); OCC.PutF5 (op, par1.typ.size, par2, par1)
  722.           ELSE
  723.             IF par1.typ.form = par2.typ.form THEN
  724.               OCI.Load (par1); IF op = OCC.EOR THEN OCI.Load (par2) END;
  725.               OCC.PutF5 (op, par1.typ.size, par2, par1); OCI.Unload (par2)
  726.             ELSE
  727.               OCS.Mark (100)
  728.             END
  729.           END
  730.         END
  731.       ELSE
  732.         OCS.Mark (111)
  733.       END
  734.     |
  735.     OCT.pBIT :
  736.       IF f IN intSet THEN
  737.         IF (par2.mode = Con) & (par2.a0 >= 8) THEN OCI.Load (par1)
  738.         ELSIF (par2.mode # Con) THEN OCI.Load (par1); OCI.Load (par2)
  739.         END;
  740.         OCC.Bit (OCC.BTST, par2, par1); OCI.Unload (par1); OCI.Unload (par2)
  741.       ELSE
  742.         OCS.Mark (111)
  743.       END;
  744.       OCE.setCC (par1, OCC.NE)
  745.     |
  746.     OCT.pGET, OCT.pGETREG :
  747.       IF par2.mode >= Con THEN OCS.Mark (112)
  748.       ELSIF ~(f IN realSet) THEN
  749.         IF par2.rdOnly THEN OCS.Mark (324) END;
  750.         OCC.Move (par2.typ.size, par1, par2)
  751.       ELSE OCS.Mark (111)
  752.       END;
  753.       par1.typ := OCT.notyp
  754.     |
  755.     OCT.pPUT, OCT.pPUTREG :
  756.       IF par2.mode IN {XProc, LProc} THEN OCI.MoveAdr (par2, par1)
  757.       ELSIF f IN putSet THEN OCC.Move (par2.typ.size, par2, par1)
  758.       ELSE OCS.Mark (111)
  759.       END;
  760.       par1.typ := OCT.notyp
  761.     |
  762.     OCT.pSYSNEW :
  763.       x.mode := Push; x.a0 := SP;
  764.       IF par2.typ.form # LInt THEN OCE.ConvertInts (par2, OCT.linttyp) END;
  765.       OCC.Move (L, par2, x); OCI.Unload (par2)
  766.     |
  767.     OCT.pVAL : par2.typ := par1.typ; par1 := par2
  768.     |
  769.     OCT.pCOPY :
  770.       IF
  771.         ((f = Array) OR (f = DynArr)) & (par2.typ.BaseTyp.form = Char)
  772.       THEN
  773.         IF par2.rdOnly THEN OCS.Mark (324) END;
  774.         IF f = Array THEN
  775.           x.mode := Con; x.a0 := par2.typ.n;
  776.           IF (par1.typ.form = String) & (par1.a1 < x.a0) THEN
  777.             x.a0 := par1.a1
  778.           ELSIF (par1.typ.form = Array) & (par1.typ.n < x.a0) THEN
  779.             x.a0 := par1.typ.n
  780.           END;
  781.           DEC (x.a0); OCE.SetIntType (x)
  782.         ELSE
  783.           IF (par1.typ.form = String) & (par1.a1 = 1) THEN
  784.             x.mode := Con; x.a0 := 0; x.typ := OCT.sinttyp
  785.           ELSE OCI.DescItem (x, par2.desc, par2.typ.adr)
  786.           END
  787.         END;
  788.         OCI.CopyString (par1, par2, x)
  789.       ELSE
  790.         OCS.Mark (111)
  791.       END;
  792.       par1.typ := OCT.notyp
  793.     |
  794.     OCT.pMOVE :
  795.       IF (f IN adrSet) THEN
  796.         x.mode := Push; x.a0 := SP;
  797.         OCC.Move (L, par2, x); OCI.Unload (par2)
  798.       ELSE
  799.         OCS.Mark (111)
  800.       END
  801.     |
  802.   ELSE
  803.     OCS.Mark (1015); OCS.Mark (fctno)
  804.   END; (* CASE fctno *)
  805.   (* ;OCM.TraceOut (mname, pname); *)
  806. END StPar2;
  807.  
  808. (*------------------------------------*)
  809. PROCEDURE StPar3 * (VAR p, x : OCT.Item; fctno : INTEGER; VAR R : SET);
  810.  
  811.   (* CONST pname = "StPar3"; *)
  812.  
  813.   VAR f : INTEGER; y : OCT.Item;
  814.  
  815. BEGIN (* StPar3 *)
  816.   (* OCM.TraceIn (mname, pname); *)
  817.   f := x.typ.form;
  818.   IF fctno = OCT.pMOVE THEN
  819.     IF f IN intSet THEN
  820.       IF f # LInt THEN OCE.ConvertInts (x, OCT.linttyp) END;
  821.       y.mode := Push; y.a0 := SP;
  822.       OCC.Move (L, x, y); OCI.Unload (x);
  823.       OCC.CallKernel (OCC.kMove);
  824.       y.mode := Undef; OCC.RestoreRegisters (R, y)
  825.     ELSE
  826.       OCS.Mark (111)
  827.     END;
  828.     p.typ := OCT.notyp
  829.   ELSE
  830.     OCS.Mark (64)
  831.   END
  832.   (* ;OCM.TraceOut (mname, pname); *)
  833. END StPar3;
  834.  
  835. (*------------------------------------*)
  836. PROCEDURE StFct * (VAR p : OCT.Item; fctno, parno : INTEGER; VAR R : SET);
  837.  
  838.   (* CONST pname = "StFct"; *)
  839.  
  840.   VAR
  841.     p2, r0, r1, x, y : OCT.Item; L0, f, f1, proc : INTEGER;
  842.     btyp : OCT.Struct;
  843.  
  844. BEGIN (* StFct *)
  845.   (* OCM.TraceIn (mname, pname); *)
  846.   IF fctno >= OCT.TwoPar THEN
  847.     IF (fctno = OCT.pASSERT) & (parno = 1) THEN
  848.       IF p.mode # Coc THEN
  849.         OCC.PutF1 (OCC.TST, B, p);                    (*    TST.B <p>     *)
  850.         OCI.Unload (p); L0 := OCC.pc;
  851.         OCC.PutWord (OCC.BNE)                         (*    BNE.S 2$      *)
  852.       ELSE
  853.         OCC.PutWord (OCC.Bcc + (SHORT (p.a0) * 100H));
  854.         OCC.PutWord (SHORT (p.a1));                   (*    Bcc   2$      *)
  855.         L0 := OCC.pc - 2; OCC.FixLink (p.a2);
  856.       END;
  857.       p2.mode := Con; p2.a0 := 20; p2.typ := OCT.linttyp;
  858.       r0.mode := Reg; r0.a0 := D0;
  859.       OCC.Move (L, p2, r0); OCI.Unload (p2);  (* 1$ MOVE.L #20,D0        *)
  860.       x.mode := Con; x.a0 := 0; x.typ := OCT.stringtyp;
  861.       x.label := OCT.ConstLabel;
  862.       OCC.PutF2 (OCC.LEA, x, A0);             (*    LEA    ModuleName,A0 *)
  863.       x.a0 := (OCS.line * 10000H) + OCS.col; x.typ := OCT.linttyp;
  864.       r1.mode := Reg; r1.a0 := D1;
  865.       OCC.Move (L, x, r1);                    (*    MOVE.L pos,D1        *)
  866.       OCC.CallKernel (OCC.kHalt);             (*    JSR    Kernel.Halt   *)
  867.       IF p.mode # Coc THEN                    (* 2$                      *)
  868.         OCC.PatchWord (L0, OCC.pc - L0 - 2)
  869.       ELSE OCC.FixLink (L0)
  870.       END;
  871.       p.typ := OCT.notyp
  872.     ELSIF (fctno = OCT.pDEC) & (parno = 1) THEN
  873.       IF p.rdOnly THEN OCS.Mark (324) END;
  874.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  875.       OCC.PutF5 (OCC.SUB, p.typ.size, p2, p);
  876.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  877.       p.typ := OCT.notyp
  878.     ELSIF (fctno = OCT.pINC) & (parno = 1) THEN
  879.       IF p.rdOnly THEN OCS.Mark (324) END;
  880.       p2.mode := Con; p2.a0 := 1; p2.typ := p.typ;
  881.       OCC.PutF5 (OCC.ADD, p.typ.size, p2, p);
  882.       IF OCS.pragma [OCS.ovflChk] THEN OCC.Trap (OCC.OverflowCheck) END;
  883.       p.typ := OCT.notyp
  884.     ELSIF (fctno = OCT.pLEN) & (parno = 1) THEN
  885.       IF p.typ.form = DynArr THEN OCI.DescItem (p, p.desc, p.typ.adr)
  886.       ELSE p.mode := Con; p.a0 := p.typ.n; p.typ := OCT.linttyp
  887.       END
  888.     ELSIF fctno = OCT.pINLINE THEN
  889.       p.typ := OCT.notyp
  890.     ELSIF fctno = OCT.pSYSNEW THEN
  891.       IF
  892.         ((p.typ.form = Pointer) & (p.typ.sysflg = OberonFlag))
  893.         OR (p.typ.form = PtrTyp)
  894.       THEN
  895.         OCC.PutWord (50E7H)                           (* ST     -(A7)     *)
  896.       ELSE
  897.         OCC.PutWord (51E7H)                           (* SF     -(A7)     *)
  898.       END;
  899.       OCC.CallKernel (OCC.kNewSysBlk);                (* JSR    NewSysBlk *)
  900.       IF p.typ.sysflg = BCPLFlag THEN
  901.         OCC.PutWord (-1B80H)                          (* ASR.L  #2,D0     *)
  902.       END;
  903.       x.mode := Undef; OCC.RestoreRegisters (R, x);
  904.       r0.mode := Reg; r0.a0 := D0;
  905.       OCC.Move (L, r0, p);                            (* MOVE.L D0,<var>  *)
  906.       p.typ := OCT.notyp
  907.     ELSIF (parno < 2) OR (fctno = OCT.pMOVE) & (parno < 3) THEN
  908.       OCS.Mark (65)
  909.     END
  910.   ELSIF (fctno = OCT.pNEW) & (parno >= 1) THEN
  911.     f := p.typ.form;
  912.     IF f = Pointer THEN
  913.       f1 := p.typ.sysflg; btyp := p.typ.BaseTyp; f := btyp.form;
  914.       r0.mode := Reg; r0.a0 := D0;
  915.       IF (f1 = OberonFlag) & NeedsTag (btyp) THEN
  916.         IF f = Record THEN
  917.           IF parno > 1 THEN OCS.Mark (64) END;
  918.           proc := OCC.kNewRecord
  919.         ELSIF f = Array THEN
  920.           IF parno > 1 THEN OCS.Mark (64) END;
  921.           proc := OCC.kNewArray
  922.         ELSIF f = DynArr THEN
  923.           WHILE btyp.form = DynArr DO btyp := btyp.BaseTyp; DEC (parno) END;
  924.           WHILE btyp.form = Array DO btyp := btyp.BaseTyp END;
  925.           IF parno > 1 THEN OCS.Mark (64)
  926.           ELSIF parno < 1 THEN OCS.Mark (65)
  927.           END;
  928.           proc := OCC.kNewArray
  929.         END
  930.       ELSE
  931.         IF f1 = OberonFlag THEN
  932.           IF f = DynArr THEN
  933.             WHILE btyp.form = DynArr DO
  934.               btyp := btyp.BaseTyp; DEC (parno)
  935.             END;
  936.             IF parno > 1 THEN OCS.Mark (64)
  937.             ELSIF parno < 1 THEN OCS.Mark (65)
  938.             END
  939.           END;
  940.           OCC.PutWord (50E7H)                     (* ST     -(A7)        *)
  941.         ELSE
  942.           OCC.PutWord (51E7H)                     (* SF     -(A7)        *)
  943.         END;
  944.         proc := OCC.kNewSysBlk
  945.       END;
  946.       OCC.CallKernel (proc);
  947.       IF f1 = BCPLFlag THEN OCC.PutWord (-1B80H) END;(* ASR.L  #2,D0     *)
  948.       x.mode := Undef; OCC.RestoreRegisters (R, x);
  949.       OCC.Move (L, r0, p);                           (* MOVE.L D0,<var>  *)
  950.     END;
  951.     p.typ := OCT.notyp
  952.   ELSIF parno < 1 THEN
  953.     OCS.Mark (65)
  954.   END
  955.   (* ;OCM.TraceOut (mname, pname); *)
  956. END StFct;
  957.  
  958. (*------------------------------------*)
  959. PROCEDURE Inline * (VAR x : OCT.Item);
  960.  
  961.   (* CONST pname = "Inline"; *)
  962.  
  963.   VAR f : INTEGER;
  964.  
  965. BEGIN (* Inline *)
  966.   (* OCM.TraceIn (mname, pname); *)
  967.   f := x.typ.form;
  968.   IF (f IN intSet) & (x.mode = Con) THEN
  969.     IF f = LInt THEN OCC.PutLong (x.a0)
  970.     ELSE OCC.PutWord (SHORT (x.a0))
  971.     END
  972.   ELSE
  973.     OCS.Mark (17)
  974.   END
  975.   (* ;OCM.TraceOut (mname, pname); *)
  976. END Inline;
  977.  
  978. (*------------------------------------*)
  979. PROCEDURE NewPar * (VAR x, p0, p1 : OCT.Item; n : INTEGER);
  980.  
  981.   (* CONST pname = "NewPar"; *)
  982.  
  983.   VAR f, i : INTEGER; btyp : OCT.Struct; desc, r0, y : OCT.Item;
  984.       calcSize : BOOLEAN;
  985.  
  986. BEGIN (* NewPar *)
  987.   (* OCM.TraceIn (mname, pname); *)
  988.   IF p1.typ.form IN intSet THEN
  989.     f := x.typ.form;
  990.     IF (f = Pointer) & (x.typ.sysflg = OberonFlag) THEN
  991.       btyp := x.typ; i := 0;
  992.       WHILE (btyp.BaseTyp # NIL) & (i < n) DO
  993.         btyp := btyp.BaseTyp; INC (i)
  994.       END;
  995.       f := btyp.form;
  996.       IF f = DynArr THEN
  997.         IF p1.typ.form # LInt THEN OCE.ConvertInts (p1, OCT.linttyp) END;
  998.         OCI.DescItem (desc, x.desc, btyp.adr);
  999.         OCC.Move (L, p1, desc);
  1000.         OCI.UpdateDesc (desc, btyp.adr);
  1001.         btyp := btyp.BaseTyp; f := btyp.form;
  1002.         IF p1.mode = Con THEN
  1003.           IF f # DynArr THEN p1.a0 := p1.a0 * btyp.size END;
  1004.           calcSize := FALSE
  1005.         ELSE
  1006.           calcSize := TRUE
  1007.         END;
  1008.         IF n = 1 THEN p0 := p1
  1009.         ELSE OCE.Op (OCS.times, p0, p1, TRUE)
  1010.         END;
  1011.         IF calcSize & (f # DynArr) & (btyp.size > 1) THEN
  1012.           y.mode := Con; y.a0 := btyp.size; y.typ := OCT.linttyp;
  1013.           OCE.Op (OCS.times, p0, y, TRUE)
  1014.         END;
  1015.         IF f # DynArr THEN
  1016.           OCI.UnloadDesc (x);
  1017.           y.mode := Push; y.a0 := SP;
  1018.           OCC.Move (L, p0, y); OCI.Unload (p0)
  1019.         END;
  1020.       ELSE OCS.Mark (64)
  1021.       END
  1022.     ELSE OCS.Mark (64)
  1023.     END
  1024.   ELSE OCS.Mark (328)
  1025.   END
  1026.   (* ;OCM.TraceOut (mname, pname); *)
  1027. END NewPar;
  1028.  
  1029. END OCP.
  1030.  
  1031. (***************************************************************************
  1032.  
  1033.   $Log: OCP.mod $
  1034.   Revision 5.9  1995/01/26  00:17:17  fjc
  1035.   - Release 1.5
  1036.  
  1037.   Revision 5.8  1995/01/03  21:22:07  fjc
  1038.   - Changed OCG to OCM.
  1039.  
  1040.   Revision 5.7  1994/12/16  17:33:01  fjc
  1041.   - Changed Symbol to Label.
  1042.  
  1043.   Revision 5.6  1994/11/13  11:31:33  fjc
  1044.   - Changed handling of ENTIER.
  1045.   - [bug] ABS now implemented for reals.
  1046.   - Implemented SYSTEM.CC.
  1047.  
  1048.   Revision 5.5  1994/10/23  16:16:31  fjc
  1049.   - Complete overhaul:
  1050.     - Added SaveRegs().
  1051.     - Removed code for handling obsolete SYSTEM procedures:
  1052.       GC, RC, ARGLEN, ARGS, SIZETAG, SETCLEANUP, BIND,
  1053.       GETNAME and NEWTAG.
  1054.     - All access to RTS is now through OCC.CallKernel().
  1055.  
  1056.   Revision 5.4  1994/09/25  18:01:55  fjc
  1057.   - Changed to reflect new object modes and system flags.
  1058.  
  1059.   Revision 5.3  1994/09/15  10:36:36  fjc
  1060.   - Replaced switches with pragmas.
  1061.  
  1062.   Revision 5.2  1994/09/08  10:50:49  fjc
  1063.   - Changed to use pragmas/options.
  1064.  
  1065.   Revision 5.1  1994/09/03  19:29:08  fjc
  1066.   - Bumped version number
  1067.  
  1068. ***************************************************************************)
  1069.